Predicción del precio de los jugadores en las 5 ligas de futbol europeas mas importantes

Enfoque Estadístico del Aprendizaje

#Librerias
library(tidyverse)
library(tidymodels)
library(GGally)
library(ggplot2)
library(MASS)
library(robustbase)
library(dplyr)
library(corrplot)
library(caret)
library(viridis)
library(gridExtra)
library(kableExtra)

Objetivo

El fútbol es el deporte más popular, el que tiene un mercado más grande y en el cual el valor de las transferencias de los jugadores es el más alto. En ese sentido, nos proponemos analizar las transferencias y cotizaciones de los jugadores de la liga inglesa, una de las mejores ligas del mundo.

Por este motivo, y haciendo uso de los conocimientos aportados por la materia, optamos por profundizar en el desarrollo de métodos de regresión robustos para hacer análisis predictivos, haciendo foco en la explicabilidad del modelo para predecir las transferencias de los jugadores.

El objetivo del presente trabajo consiste en la utilización distintos métodos robustos para predecir la variable objetivo: el precio de transferencia de los jugadores.

• Observar si el país de origen es una variable explicativa con respecto a la variable objetivo.
• Identificar si los ratios que demuestran el desempeño de los jugadores generan impacto sobre la transferencia de los jugadores.
• Utilizar la regresión regresión de mínimos cuadrados ponderados, regresión de mínimos cuadrados robustos (Huber).
• Comparar el desempeño de los distintos modelos para predecir la variable objetivo.

Introducción

En el método lineal clásico se utiliza el método de cuadrados mínimos para encontrar los parámetros \(\beta\).

La función de pérdida que se quiere minimizar es la suma del cuadrado de los residuos.

\[ g(a, b) = \sum_{i=1}^n \left( Y_i - \left( a + b X_i \right) \right)^2 \quad \text{(1)} \]

En los modelos lineales robustos queremos cambiar la función de perdida tal que:

• Sea Insensible a valores extremadamente grandes o outliers(o residuos grandes)
• Crezca menos que mínimos cuadrados cuando miramos lo suficientemente lejos del cero
• Tenga Alta eficiencia: si los datos de la muestra siguieran el modelo de regresión con errores normales, queremos que el estimador (beta) que el método robusta calcula se parezca al de mínimos cuadrados, por lo que la función de pérdida que el método robusto calcula debería parecerse al de mínimos cuadrado.

\[ g(a, b) = \sum_{i=1}^n \rho \left( \frac{Y_i - \left( a + b X_i \right)}{s_n} \right) \quad \text{(2)} \] Definición de \(\rho\)

-\(\rho\) : R →R.

Una función-\(\rho\) denotará a una función \(\rho\)(u) tal que:

-\(\rho\)(0) = 0.

-\(\rho\)(−u) = \(\rho\)(u).

-0 ≤ u ≤ v implica \(\rho\)(u) ≤ \(\rho\)(v).

-\(\rho\) es continua.

-sup~u \(\rho\)(u) = 1.

Si \(\rho\)(u) < 1 y 0 ≤ u < v entonces \(\rho\)(u) < \(\rho\)(v).

es una función acotada, creciente y simétrica alrededor del cero, y \(s_n\) es un estimador de escala que juega el papel de σ en el modelo clásico de regresión.

Una posibilidad es ajustar una recta usando un procedimiento de ajuste robusto, por ejemplo un MM-estimador de regresión, propuesto por Yohai [1987]. En R, esto está programado dentro de la rutina lmrob en el paquete robustbase de R. La estimación se hace en tres etapas, se propone un estimador inicial de los parámetros, a partir de él se estima a sn y manualmente se obtienen los estimadores de los parámetros a partir de ellos, minimizando la función objetivo

Existen varias funciones \(\rho\) que serán evaluadas en el presente trabajo. Por defecto, robustbase utiliza la bicuadrada (bisquare), pero también se pueden implementar lqq, welsh, optimal, etc.

Robustbase utiliza el algoritmo Iteratively Reweighted Least Squares (IRWLS) para estimar los parámetros \(\beta\). El proceso consiste en la siguientes etapas:

1. Inicializar el proceso utilizando un estimación inicial de a y b utilizando el método de cuadrados mínimos.

2. Derivar la función (2) respecto a los parámetros a y b: \[ \frac{\partial g}{\partial a} = \sum_{i=1}^{n} \psi \left(\frac{Y_i - (a + bX_i)}{s_n} \right) \cdot \frac{-1}{s_n} \quad \text{(3)} \] \[ \frac{\partial g}{\partial b} = \sum_{i=1}^{n} \psi \left(\frac{Y_i - (a + bX_i)}{s_n} \right) \cdot \frac{-X_i}{s_n} \quad \text{(4)} \]

donde

\[ \frac{d \rho(x)}{dx} = \psi(x) \quad \text{(5)} \]

3. Se calculan los pesos de cada observacion

\[ w_i = \frac{\psi \left(\frac{Y_i - (a + bX_i)}{s} \right)}{\frac{Y_i - (a + bX_i)}{s}} \quad \text{(6)} \]

4. Se multiplica a cada observación por su respectivo peso.

5. Se vuelven a estimar los parámetros a y b con una regresión ponderada.

Se repiten los pases hasta no observar mas mejoras o hasta un máximo de iteraciones.

A continuación de muestras Las funciones \(\rho\) más comunes y como se comportan los pesos de las mismas.

1. Bisquare (Tukey): \[ \rho(x) = \begin{cases} 1 - (1 - (x/k)^2)^3 & \text{si } |x| \leq k \\ 1 & \text{si } |x| > k \end{cases} \quad \text{(7)} \]

# set margins for plots
options(SweaveHooks=list(fig=function() par(mar=c(3,3,1.4,0.7),
                                            mgp=c(1.5, 0.5, 0))))
## x axis for plots:
x. <- seq(-5, 10, length.out = 1501)
source(system.file("xtraR/plot-psiFun.R", package = "robustbase", mustWork=TRUE))
getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "biweight", par = 4.685)

2. Huber: \[ \rho(x) = \begin{cases} \frac{x^2}{2} & \text{si } |x| \leq k \\ k|x| - \frac{k^2}{2} & \text{si } |x| > k \end{cases} \quad \text{(8)} \]

getOption("SweaveHooks")[["fig"]]()
plot(huberPsi, x., ylim=c(-1.4, 5), leg.loc="topright", main=FALSE)

3. Welsh: \[ \rho(x) = 1 - \exp(-x^2/k^2) \quad \text{(9)} \]

getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "Welsh", par = 2.11)

4. Hampel: \[ \rho(x) = \begin{cases} \frac{x^2}{2} & \text{si } |x| \leq a \\ a|x| - \frac{a^2}{2} & \text{si } a < |x| \leq b \\ \frac{a(c|x| - x^2/2 - bc + b^2/2)}{c-b} & \text{si } b < |x| \leq c \\ a(c - \frac{b}{2}) & \text{si } |x| > c \end{cases} \quad \text{(10)} \]

getOption("SweaveHooks")[["fig"]]()
## see also hampelPsi
p.psiFun(x., "Hampel", par = ## Default, but rounded:
           round(c(1.5, 3.5, 8) * 0.9016085, 1))

5. LQQ (Linearly Quadratically Quadratic): \[ \rho(x) = \begin{cases} \frac{x^2}{2} & \text{si } |x| \leq c_1 \\ c_1|x| - \frac{c_1^2}{2} & \text{si } c_1 < |x| \leq c_2 \\ \frac{(c_3|x| - x^2/2)}{c_3-c_2} & \text{si } c_2 < |x| \leq c_3 \\ c_3 & \text{si } |x| > c_3 \end{cases} \quad \text{(11)} \]

getOption("SweaveHooks")[["fig"]]()
p.psiFun(x., "LQQ", par = c(-.5,1.5,.95,NA))

6. Optimal \[ \psi(x) = \begin{cases} x & \text{si } |x| \leq a \\ a \cdot \text{sign}(x) \cdot \left(1 - \left(\frac{|x| - a}{b - a}\right)^2\right)^2 & \text{si } b < |x| \leq c \\ 0 & \text{si } |x| > c \end{cases} \quad \text{(12)} \]

Donde \(k\), \(a\), \(b\), \(c\), \(c_1\), \(c_2\) y \(c_3\) son constantes que determinan los puntos de quiebre y la forma de cada función.

Existen muchas otras propuestas de estimadores robustos para regresión, por ejemplo LMS (least median of squares), LTS (least trimmed squares), τ−estimadores de regresión, y casi todas están implementadas en R.

Dataset

El set de datos consiste en dos bases, ambas obtenidas de Kaggle.

La base de datos con los precios de los jugadores se obtuvo de la web Transfermarkt. Cuenta con 32405 registros, y dos de sus variables son los precios actuales de los jugadores y el precio mas alta alcanzado. Además cuenta con la información del club y liga actual de cada jugador.

Las otra base de datos cuenta con las métricas durante la temporada 2023/2023 de los jugadores de las 5 ligas mas importantes del fútbol europeo. Algunas de sus variables son Edad, goles anotados, asistencias, posición dentro del campo de juego, nacionalidad, entre otras.

Ambas bases de datos se unieron por el nombre y apellido del jugador, y el club actual. Adicionalmente, se agregó la variable Continente al dataset final, la cual informa el continente natal de cada jugador.

El dataset se divide en Entrenamiento y Prueba, de manera estratificada según el precio. Se utiliza el siguiente boxplot para generar una nueva categoría que categorice según el precio del jugador.

Luego utilizaremos esta nueva variable para realizar la división del dataset de manera estratificada.

Categorías de la nueva variable

• Muy bajo: Menor a mediana (Q2)
• Bajo: entre mediana (Q2) y cuartil superior (Q3)
• Medio: entre cuartil superior (Q3) y límite superior (Q3 + 1.5 x IQR)
• Alto: entre limite superior y €100.000.000
• Muy Alto: mayor a €100.000.000 (representa los 10 jugadores mas caros)

El objetivo es que quedan estratificados los jugadores mas caros u outliers, por eso no se realiza una división por debajo de Q2.

# Carga de datset
df <- as.data.frame(read.csv("dataset.csv"))
df <- as.data.frame(df)
df <- na.omit(df)
colnames(df)[colnames(df) == "market_value_in_eur"] <- "precio"

# Agregar nueva variable que tenga en cuenta los precios de los jugadores y poder hacer un split 
# test-train estratificado
caja_precios <- boxplot(df$precio)

df$precio_cat <- NA

for (i in 1:length(df$precio)) {
  if (df$precio[i] >= 100000000) { 
    df$precio_cat[i] <- "muy_alto"}
  if (df$precio[i] < 100000000 && df$precio[i] >= caja_precios$stats[5]) {
    df$precio_cat[i] <- "alto"}
  if (df$precio[i] < caja_precios$stats[5] && df$precio[i] >= caja_precios$stats[4]) {
    df$precio_cat[i] <- "medio"}
  if (df$precio[i] < caja_precios$stats[4] && df$precio[i] >= caja_precios$stats[3]) {
    df$precio_cat[i] <- "bajo"}
  if (df$precio[i] < caja_precios$stats[3]){
    df$precio_cat[i] <- "muy_bajo"}
}

# Suponiendo que `df$clase` es la variable categórica
set.seed(28749658)  # Fijar semilla para reproducibilidad

# Crear índices estratificados basados en la variable `clase`
train_indices <- createDataPartition(df$precio_cat, p = 0.7, list = FALSE)  # 70% entrenamiento

# Dividir los datos
train_data <- df[train_indices, ]
test_data <- df[-train_indices, ]

Verificar la distribución de clases

Datos de Entrenamiento

table(train_data$precio_cat)

## 
##     alto     bajo    medio muy_alto muy_bajo 
##      132      298      171       10      546

Datos de prueba

table(test_data$precio_cat)

## 
##     alto     bajo    medio muy_alto muy_bajo 
##       56      127       73        4      234

Análisis Exploratorio de Datos

Gráficos de barras de algunas variables categóricas

colnames(df)[colnames(df) == "market_value_in_eur"] <- "precio"
df$continente <- factor(df$continente, levels = c("europa", "america", "africa", "asia_oceania"))
grafico1 <- ggplot(df, aes(x=continente, fill = continente)) +
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Cantidad", 
       x = "Continente",
       title = "Cantidad de jugadores por continente") +
  theme_minimal() +
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1),
        legend.position = "none")

df$Comp <- factor(df$Comp, levels = c("es La Liga", "it Serie A", "fr Ligue 1", "de Bundesliga",
                                      "eng Premier League"))
grafico2 <- ggplot(df, aes(x=Comp, fill = Comp)) + 
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Cantidad", x = "Liga", title = "Cantidad de jugadores por liga") +
  theme_minimal() + 
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1),
        legend.position = "none")

posiciones <- table(df$position)
posiciones <- names(sort(posiciones))
df$position <- factor(df$position, levels = posiciones)
grafico3 <- ggplot(df, aes(x=position, fill = position)) + 
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Count", x = "Liga", title = "Cantidad de jugadores por posicion") +
  theme_minimal() + 
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1,),
        legend.position = "none")

grafico4 <- ggplot(df, aes(x=foot, fill = foot)) + 
  geom_bar() +
  scale_fill_viridis(discrete = TRUE, option = "D") + # Paleta accesible
  labs(y = "Count", x = "Liga", title = "Cantidad de jugadores por pie habil") +
  theme_minimal() + 
  theme(axis.text.x = element_text(angle=45, vjust=1, hjust=1,),
        legend.position = "none")

grid.arrange(grafico1, grafico2, grafico3, grafico4,nrow = 2)

Jugadores por continente

Como era de esperarse, predominan los jugadores europeos. Los americanos y africanos están casi en igual medida, siendo un poco mayor los americanos. Asia y Oceanía en conjunto aportan solo una mínima cantidad.

Cantidad de jugadores de liga

Todas las ligas están igual de representadas en el dataset, con lo cual el análisis del precio de jugadores según la liga será de interés.

Jugadores por posición

Predominan los jugadores que se desempeñan en el centro del campo, como defensores centrales o mediocampistas centrales o mixtos. Esto tiene cierta lógica ya que 3 o 4 jugadores de campo siempre se desempeñan en estas posiciones. Llama la atención la alta proporción de centrodelanteros, ya que los equipos suelen usar un solo jugador en esa posición.

Jugadores por pie hábil.

Como era de esperarse, mas de la mitad de los jugadores son derechos. Sin embargo, comparado con la proporción de personas diestras en el mundo (85%), la cantidad de jugadores zurdos es bastante mayor a estar proporción.

Correlograma

df %>% 
  dplyr::select(Age, Gls, Ast, precio) %>% 
  mutate(liga = df$current_club_domestic_competition_id) %>%
  ggpairs(., mapping = aes(colour = liga),
          upper = list(continuous = wrap("cor", size = 3, hjust=0.5)), progress=FALSE) + 
  scale_color_viridis_d(option = "D") + 
  scale_fill_viridis_d(option = "D") +
  theme(axis.text.x = element_text(angle = 90, hjust = 1), legend.position = "bottom") + 
  theme_bw() +
  labs(title='Correlograma variables continuas')

Correlación entre Goles y Precio

Se observa una correlación positiva alta a moderada (Corr: 0.502). Esto sugiere que los jugadores que marcan más goles tienden a tener un valor de mercado más alto. La relación parece ser consistente a través de las diferentes ligas.

Correlación entre Asistencias y Precio

Existe una correlación positiva moderada (Corr: 0.465). Indica que los jugadores que dan más asistencias también tienden a tener un mayor valor en el mercado. La correlación es algo menor que con los goles, sugiriendo que el mercado valora más la capacidad goleadora.

Correlación entre Edad y Precio

Se observa una correlación negativa baja pero clara (Corr: -0.176). Sugiere que el valor de mercado tiende a disminuir con la edad del jugador. Esto tiene sentido desde una perspectiva de inversión, ya que los jugadores más jóvenes tienen mayor potencial de desarrollo y años de carrera por delante.

Distribución por Ligas

Los diagramas de caja (boxplots) muestran diferencias en la distribución de precios entre ligas. Las ligas española y británica presentan valores más altos en general. Esto se alinea con el poder económico de estas ligas y específicamente de clubes como Real Madrid y Manchester City. La distribución de precios es notablemente asimétrica, con algunos valores muy altos que podrían considerarse outliers.

Correlaciones cruzadas

Existe una correlación positiva moderada entre goles y asistencias (Corr: 0.586). Esto sugiere que los jugadores más efectivos tienden a destacar tanto en goles como en asistencias. La edad muestra correlaciones muy débiles con goles y asistencias.

Jugadores mas caros

Los 10 jugadores mas caros

mas_caros_nombre <- df %>% 
  slice_max(order_by = precio, n=10)  %>% 
  pull(name)
mas_caros_equipo <- df %>% 
  slice_max(order_by = precio, n=10)  %>% 
  pull(Squad)
mas_caros_precio <- df %>% 
  slice_max(order_by = precio, n=10)  %>% 
  pull(precio)
mas_caro <- data.frame(Nombre = mas_caros_nombre, 
                       Equipo = mas_caros_equipo, 
                       Precio = mas_caros_precio)

kable(mas_caro)

Nombre	Equipo	Precio
erling haaland	manchester city	2.0e+08
vinicius junior	real madrid	2.0e+08
jude bellingham	real madrid	1.8e+08
lamine yamal	barcelona	1.5e+08
phil foden	manchester city	1.5e+08
bukayo saka	arsenal	1.4e+08
federico valverde	real madrid	1.3e+08
florian wirtz	leverkusen	1.3e+08
rodri	manchester city	1.3e+08
declan rice	arsenal	1.2e+08

Jugadores mas baratos

Los 10 jugadores mas baratos

mas_baratos_nombre <- df %>% 
  slice_min(order_by = precio, n=10)  %>% 
  pull(name)
mas_baratos_equipo <- df %>% 
  slice_min(order_by = precio, n=10)  %>% 
  pull(Squad)
mas_baratos_precio <- df %>% 
  slice_min(order_by = precio, n=10)  %>% 
  pull(precio)
mas_barato <- data.frame(Nombre = mas_baratos_nombre, 
                       Equipo = mas_baratos_equipo, 
                       Precio = mas_baratos_precio)

kable(mas_barato)

Nombre	Equipo	Precio
aurelien pelon	lorient	50000
daouda traore	nice	50000
sofiane sidi ali	marseille	50000
steven baseya	strasbourg	50000
yassin tallal	getafe	50000
simone aresti	cagliari	75000
adel mahamoud	nantes	100000
antonio mirante	milan	100000
daniele sommariva	genoa	100000
dominic sadi	bournemouth	100000
francesco rossi	atalanta	100000
ichem ferrah	lille	100000
ivan cuellar	mallorca	100000
joel imasuen	werder bremen	100000

Regresión Lineal Simple

Modelo “Goles son amores”

Precio = Goles

modelo_clasico_goles = lm(data = train_data, formula = precio ~ Gls)
summary(modelo_clasico_goles)

## 
## Call:
## lm(formula = precio ~ Gls, data = train_data)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -58318585  -5505828  -3505828   2261548 112681415 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  5238452     519499   10.08   <2e-16 ***
## Gls          3267375     147163   22.20   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 15400000 on 1155 degrees of freedom
## Multiple R-squared:  0.2991, Adjusted R-squared:  0.2985 
## F-statistic: 492.9 on 1 and 1155 DF,  p-value: < 2.2e-16

ggplot(df, aes(x= Gls, y=precio))+
  geom_point() +
  theme_bw() +
  geom_smooth(method = "lm", formula = y ~ x, color="forestgreen", se = FALSE)

Diagnóstico

datos_augmentados <- augment(modelo_clasico_goles)
g1 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g2 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g3 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g4 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g1, g2, g3, g4, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra un patrón de embudo, indicando heterocedasticidad
• El QQ-plot muestra desviaciones significativas de la normalidad, especialmente en las colas
• El Scale-location plot confirma la heterocedasticidad, con mayor variabilidad en los valores predichos más altos
• El gráfico de leverage muestra varios puntos con alta influencia que podrían estar afectando el modelo

Interpretación del Modelo

• El modelo establece una relación lineal simple entre el precio del jugador y los goles anotados
• Por cada gol anotado, se precibe un aumento estadísticamente significativo (p-value < 0.05) en el precio del jugador de €3,267,375
• El intercepto es €5,238,452, que representa el precio base estimado para un jugador sin goles
• El modelo es estadísticamente significativo (p-value < 2.2e-16)
• El R² ajustado es 0.2985, lo que indica que el modelo explica aproximadamente el 30% de la variabilidad en los precios

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_goles <- augment(modelo_clasico_goles, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  15388866

cat("MAE: ", mae(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## MAE:  9179813

Datos de prueba

pred_modelo_clasico_goles <- augment(modelo_clasico_goles, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  17503869

cat("MAE: ", mae(data = pred_modelo_clasico_goles, truth = precio, estimate = .fitted)$.estimate)

## MAE:  9732598

• En datos de entrenamiento:
  • RMSE: 15,388,866
  • MAE: 9,179,813
• En datos de prueba:
  • RMSE: 17,503,869
  • MAE: 9,732,598
• La diferencia relativamente pequeña entre los errores de entrenamiento y prueba sugiere que el modelo no está sobreajustado

Limitaciones del Modelo

• La relación lineal simple puede ser demasiado básica para capturar la complejidad del precio de los jugadores
• La presencia de heterocedasticidad sugiere que la variabilidad del precio aumenta con el número de goles
• El bajo R² indica que hay otros factores importantes que no están siendo considerados
• Los supuestos de normalidad y homocedasticidad no se cumplen adecuadamente

Este modelo, aunque estadísticamente significativo, tiene limitaciones importantes para predecir el precio de los jugadores. La violación de los supuestos básicos y el bajo poder explicativo sugieren que se necesita un modelo más complejo que incorpore variables adicionales y posiblemente transformaciones de las variables existentes.

Modelo “La edad NO es lo de menos”

Precio = \(Edad\) + \(Edad^2\)

modelo_clasico_edad = modelo_clasico_edad2 = lm(data = train_data, formula = precio ~ Age + I(Age^2))
summary(modelo_clasico_edad)

## 
## Call:
## lm(formula = precio ~ Age + I(Age^2), data = train_data)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -13491197  -9734927  -5198104   2200547 186201791 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -45547305   13549572  -3.362 0.000801 ***
## Age           5113615    1054307   4.850 1.40e-06 ***
## I(Age^2)      -110147      20094  -5.482 5.18e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 17940000 on 1154 degrees of freedom
## Multiple R-squared:  0.05018,    Adjusted R-squared:  0.04853 
## F-statistic: 30.48 on 2 and 1154 DF,  p-value: 1.255e-13

ggplot(df, aes(x= Age, y=precio))+
  geom_point() +
  theme_bw() +
  geom_smooth(method = "lm", formula = y ~ x + I(x^2), color="forestgreen", se = FALSE)

cat("A partir de los", round(5113615/(2*110147),0), "años, el precio de los jugadores comienza a disminuir")

## A partir de los 23 años, el precio de los jugadores comienza a disminuir

Diagnóstico

datos_augmentados <- augment(modelo_clasico_edad)
g1 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g2 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g3 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g4 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g1, g2, g3, g4, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra un patrón de embudo similar al modelo anterior
• El QQ-plot muestra desviaciones significativas de la normalidad, especialmente en las colas superiores
• El Scale-location plot indica heterocedasticidad
• El gráfico de leverage muestra algunos puntos influyentes, aunque menos pronunciados que en el modelo de goles

Interpretación del Modelo

• El modelo establece una relación cuadrática entre el precio del jugador y su edad
• El precio aumenta con la edad hasta los 23 años, punto a partir del cual comienza a disminuir
• Los coeficientes son:
  • Edad: +5,113,615 (efecto lineal positivo)
  • Edad²: -110,147 (efecto cuadrático negativo)
  • Intercepto: -45,547,305
• El modelo es estadísticamente significativo (p-value: 1.255e-13)
• El R² ajustado es 0.04853, lo que indica que el modelo explica solo aproximadamente el 5% de la variabilidad en los precios

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_edad <- augment(modelo_clasico_edad, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  17914627

cat("MAE: ", mae(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## MAE:  10519126

Datos de prueba

pred_modelo_clasico_edad <- augment(modelo_clasico_edad, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  18482683

cat("MAE: ", mae(data = pred_modelo_clasico_edad, truth = precio, estimate = .fitted)$.estimate)

## MAE:  10655848

• En datos de entrenamiento:
  • RMSE: 17,914,627
  • MAE: 10,519,126
• En datos de prueba:
  • RMSE: 18,482,683
  • MAE: 10,655,848
• Los errores son mayores que en el modelo de goles, sugiriendo que la edad por sí sola es un predictor más débil del precio

Limitaciones del Modelo

• El muy bajo R² sugiere que la edad por sí sola no es un buen predictor del precio
• La relación cuadrática captura el hecho de que los jugadores alcanzan un pico de valor, pero el ajuste general es pobre
• Los supuestos de normalidad y homocedasticidad siguen sin cumplirse
• El modelo no captura otros factores importantes que afectan el precio

Este modelo confirma que existe una relación no lineal entre la edad y el precio de los jugadores, con un punto máximo alrededor de los 23 años. Sin embargo, su bajo poder explicativo sugiere que la edad debe combinarse con otras variables para obtener predicciones más precisas.

Regresión Lineal Múltiple

Modelo “Ahora va en serio”

\(Precio\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

modelo_clasico_multiple_1 = lm(data = train_data, 
                             formula = precio ~ Gls + Age + I(Age^2) + Ast + 
                               continente + current_club_domestic_competition_id)
summary(modelo_clasico_multiple_1)

## 
## Call:
## lm(formula = precio ~ Gls + Age + I(Age^2) + Ast + continente + 
##     current_club_domestic_competition_id, data = train_data)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -37702078  -5979937  -1352304   4179402 117568853 
## 
## Coefficients:
##                                         Estimate Std. Error t value Pr(>|t|)
## (Intercept)                             -8999579   10503367  -0.857 0.391719
## Gls                                      2189855     160682  13.629  < 2e-16
## Age                                      1607300     804050   1.999 0.045844
## I(Age^2)                                  -44966      15312  -2.937 0.003384
## Ast                                      2152607     244624   8.800  < 2e-16
## continenteamerica                        4494113    1848911   2.431 0.015223
## continenteasia_oceania                   2283362    3956794   0.577 0.564003
## continenteeuropa                         2748364    1459721   1.883 0.059981
## current_club_domestic_competition_idFR1 -4436917    1268565  -3.498 0.000487
## current_club_domestic_competition_idGB1 11060116    1286087   8.600  < 2e-16
## current_club_domestic_competition_idIT1 -2429060    1229943  -1.975 0.048515
## current_club_domestic_competition_idL1  -4011806    1265818  -3.169 0.001568
##                                            
## (Intercept)                                
## Gls                                     ***
## Age                                     *  
## I(Age^2)                                ** 
## Ast                                     ***
## continenteamerica                       *  
## continenteasia_oceania                     
## continenteeuropa                        .  
## current_club_domestic_competition_idFR1 ***
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1 *  
## current_club_domestic_competition_idL1  ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 13350000 on 1145 degrees of freedom
## Multiple R-squared:  0.4783, Adjusted R-squared:  0.4733 
## F-statistic: 95.43 on 11 and 1145 DF,  p-value: < 2.2e-16

Diagnóstico

datos_augmentados <- augment(modelo_clasico_multiple_1)
g5 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g6 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g7 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g8 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g5, g6, g7, g8, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra una mejora en el patrón de heterocedasticidad
• El QQ-plot indica una mejor aproximación a la normalidad en el centro de la distribución
• El Scale-location plot muestra una variabilidad más estable que los modelos anteriores
• El gráfico de leverage identifica menos puntos influyentes extremos

Interpretación del Modelo

• El modelo incorpora múltiples variables predictoras: goles, edad (lineal y cuadrática), asistencias, continente de origen y liga
• Los coeficientes más significativos son:
  • Goles: +2,189,855 por gol (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta €2,189,855 por cada gol anotado
  • Asistencias: +2,152,607 por asistencia (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta €2,152,607 por cada asistencia adicional.
  • Edad: efecto cuadrático con máximo alrededor de los 23 años
  • América: +4,494,113 respecto a África (p-value = 0.015)
  • Premier League: +11,060,116 respecto a la liga de referencia, La Liga (España) (p-value < 2e-16)
  • Ligue 1: -4,436,917 respecto a la liga de referencia, La Liga (p-value < 0.05)
  • Bundesliga: -4,011,806 respecto a la liga de referencia, La Liga (p-value < 0.05)
  • Serie A (Italia): -2,429,060 respecto a la liga de referencia, La Liga (p-value < 0.05)
• El R² ajustado es 0.4733, indicando que el modelo explica aproximadamente el 47% de la variabilidad

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_multiple_1 <- augment(modelo_clasico_multiple_1, newdata = train_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  13276913

cat("MAE: ", mae(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## MAE:  8093280

Datos de prueba

pred_modelo_clasico_multiple_1 <- augment(modelo_clasico_multiple_1, newdata = test_data)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## RMSE:  15450180

cat("MAE: ", mae(data = pred_modelo_clasico_multiple_1, truth = precio, estimate = .fitted)$.estimate)

## MAE:  8469906

• En datos de entrenamiento:
  • RMSE: 13,276,913
  • MAE: 8,093,280
• En datos de prueba:
  • RMSE: 15,450,180
  • MAE: 8,469,906
• La diferencia moderada entre errores de entrenamiento y prueba sugiere un nivel aceptable de generalización

Mejoras Respecto a Modelos Anteriores

• El R² ajustado aumentó significativamente (de 0.30 y 0.05 a 0.47)
• Los errores de predicción (RMSE y MAE) disminuyeron
• Los diagnósticos de residuos muestran mejores propiedades estadísticas
• La incorporación de variables categóricas captura efectos específicos por continente y liga

Este modelo representa una mejora sustancial sobre los modelos simples anteriores, capturando efectos más complejos y reduciendo los errores de predicción. Sin embargo, aún hay espacio para mejoras, especialmente en el tratamiento de valores extremos y la posible incorporación de más variables relevantes.

Modelo “Ahora va en serio 2”

\(log(Precio)\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

Al utilizar una transformación logarítmica, la interpretación del modelo es diferente. La variación de la variable a predecir es en términos porcentuales según aumenta en una unidad la variable predictora numérica o según la variable de referencia categórica.

Por lo tanto:

\[ c = (\exp(b) - 1) \times 100 \quad \text{(13)} \]

Donde

\[ y = a + b \times x \quad \text{(14)} \]

En este caso, si \(x\) es una variable numérica entonces \(y\) varía \(c\)% por cada aumento de \(x\) en una unidad. Si en cambio \(x\) es una variable categórica, \(y\) varía \(c\)% con respecto a la variable categórica de referencia.

modelo_clasico_multiple = lm(data = train_data, 
                                formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                  continente + current_club_domestic_competition_id)
summary(modelo_clasico_multiple)

## 
## Call:
## lm(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + continente + 
##     current_club_domestic_competition_id, data = train_data)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -4.0055 -0.6931  0.0515  0.7146  3.5105 
## 
## Coefficients:
##                                          Estimate Std. Error t value Pr(>|t|)
## (Intercept)                              5.573579   0.844203   6.602 6.19e-11
## Gls                                      0.116194   0.012915   8.997  < 2e-16
## Age                                      0.787591   0.064625  12.187  < 2e-16
## I(Age^2)                                -0.016285   0.001231 -13.232  < 2e-16
## Ast                                      0.172888   0.019662   8.793  < 2e-16
## continenteamerica                        0.404139   0.148605   2.720  0.00664
## continenteasia_oceania                   0.007232   0.318025   0.023  0.98186
## continenteeuropa                         0.041694   0.117324   0.355  0.72237
## current_club_domestic_competition_idFR1 -0.296188   0.101960  -2.905  0.00374
## current_club_domestic_competition_idGB1  0.817675   0.103369   7.910 6.02e-15
## current_club_domestic_competition_idIT1 -0.027229   0.098856  -0.275  0.78303
## current_club_domestic_competition_idL1  -0.285435   0.101740  -2.806  0.00511
##                                            
## (Intercept)                             ***
## Gls                                     ***
## Age                                     ***
## I(Age^2)                                ***
## Ast                                     ***
## continenteamerica                       ** 
## continenteasia_oceania                     
## continenteeuropa                           
## current_club_domestic_competition_idFR1 ** 
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1    
## current_club_domestic_competition_idL1  ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 1.073 on 1145 degrees of freedom
## Multiple R-squared:  0.467,  Adjusted R-squared:  0.4619 
## F-statistic: 91.21 on 11 and 1145 DF,  p-value: < 2.2e-16

Diagnóstico

datos_augmentados <- augment(modelo_clasico_multiple)
g9 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g10 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g11 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g12 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g9, g10, g11, g12, nrow=2)

Diagnóstico de Residuos

• El gráfico de residuos vs valores predichos muestra una distribución más homogénea
• El QQ-plot indica una notable mejora en la normalidad de los residuos
• El Scale-location plot muestra una varianza más estable
• El gráfico de leverage sugiere menos influencia de valores extremos

Interpretación del Modelo

• El modelo utiliza la transformación logarítmica de la variable precio y mantiene las mismas variables predictoras
• Los coeficientes más significativos son:
  • Goles: +0.116 (p-value < 2e-16).Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta un 12.3% por cada gol anotado.
  • Asistencias: +0.173 (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta un 18.9% por cada asistencia adicional.
  • Edad: efecto cuadrático significativo (p-value < 2e-16)
  • América: +0.404 respecto a África (p-value = 0.007), indica un aumento estadísticamete significativo de 49.8% en el precio de los jugadores americanos con respecto a los africanos.
  • Premier League: +0.818 respecto a la liga de referencia, (p-value < 2e-16) indica un aumento estadísticamente significativo de 126.5% en el precio de los jugadores de la Premier League con respecto a los jugadores de La Liga (España)
  • Ligue 1 (Francia): -0.296 respecto a la liga de referencia, (p-value = 0.003) indica una disminución estadísticamente significativa de 25.6% en el precio de los jugadores de la Ligue 1 con respecto a los jugadores de La Liga.
  • Bundesliga: -0.285 respecto de la liga de referencia (p-value = 0.005) indica una disminución estadísticamente significativa de 24.8% en el preicio de los jugadores de la Bundesliga con respecto a La Liga.
• El R² ajustado es 0.4619, similar al modelo anterior pero con mejor interpretabilidad

Evaluación del Rendimiento

Datos de entrenamiento

pred_modelo_clasico_multiple <- augment(modelo_clasico_multiple, newdata = train_data)
pred_modelo_clasico_multiple$exp_fitted <- exp(pred_modelo_clasico_multiple$.fitted)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## RMSE:  28500598

cat("MAE: ", mae(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## MAE:  8057781

Datos de prueba

pred_modelo_clasico_multiple <- augment(modelo_clasico_multiple, newdata = test_data)
pred_modelo_clasico_multiple$exp_fitted <- exp(pred_modelo_clasico_multiple$.fitted)
cat("RMSE: ", rmse(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## RMSE:  17508456

cat("MAE: ", mae(data = pred_modelo_clasico_multiple, truth = precio, estimate = exp_fitted)$.estimate)

## MAE:  7357616

• En datos de entrenamiento:
  • RMSE: 28,500,598
  • MAE: 8,057,781
• En datos de prueba:
  • RMSE: 17,508,456
  • MAE: 7,357,616
• La transformación logarítmica mejora el MAE en los datos de prueba, aunque el RMSE es más alto

Mejoras Respecto al Modelo Anterior

• Mejor interpretabilidad de los coeficientes en términos de porcentajes
• Mejor cumplimiento de los supuestos de normalidad y homocedasticidad
• Reducción del MAE en datos de prueba
• Mayor estabilidad en la predicción de valores extremos

La transformación logarítmica del precio mejora las propiedades estadísticas del modelo y facilita la interpretación de los efectos. Este modelo parece más adecuado para predecir el precio de los jugadores, especialmente cuando se considera la interpretabilidad y la estabilidad de las predicciones.

Regresión Lineal Múltiple Robusta

Modelo “Goles son amores ROBUSTOS”

Precio = Goles

Se utiliza el modelo base de Robustbase, donde la fución de pérdida utilizada es la bicuadrada y utiliza el estimador MM.

modelo_lmrob_goles <- lmrob(formula = precio ~ Gls, data=train_data)
pred_modelo_lmrob_goles <- data.frame(
  Gls = train_data$Gls,
  precio_pred = predict(modelo_lmrob_goles, newdata = train_data)
)
summary(modelo_lmrob_goles)

## 
## Call:
## lmrob(formula = precio ~ Gls, data = train_data)
##  \--> method = "MM"
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -11398849  -2040823    -40823   7178107 172914731 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  3040823     233384   13.03  < 2e-16 ***
## Gls           890535     123689    7.20 1.08e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Robust residual standard error: 3632000 
## Multiple R-squared:  0.2183, Adjusted R-squared:  0.2177 
## Convergence in 23 IRWLS iterations
## 
## Robustness weights: 
##  158 observations c(3,19,23,52,55,58,67,76,80,83,89,92,105,112,130,132,141,143,144,156,161,163,164,167,172,173,175,178,190,200,204,212,216,218,226,232,248,253,256,262,265,271,283,287,288,289,290,292,301,309,310,316,319,321,322,327,333,338,339,341,354,366,367,368,372,384,385,388,390,407,433,461,463,474,476,482,484,488,489,500,501,510,526,537,543,563,564,565,575,578,584,586,593,597,602,608,630,634,640,646,662,666,674,691,695,696,705,713,736,753,754,760,764,774,793,799,800,801,806,811,813,823,833,853,857,867,870,871,875,901,913,917,918,929,934,953,954,962,963,965,968,973,982,1024,1036,1052,1053,1063,1070,1091,1096,1100,1123,1124,1132,1134,1138,1154)
##   are outliers with |weight| <= 4.7e-05 ( < 8.6e-05); 
##  44 weights are ~= 1. The remaining 955 ones are summarized as
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
## 0.002176 0.877400 0.959300 0.855000 0.983700 0.999000 
## Algorithmic parameters: 
##        tuning.chi                bb        tuning.psi        refine.tol 
##         1.548e+00         5.000e-01         4.685e+00         1.000e-07 
##           rel.tol         scale.tol         solve.tol          zero.tol 
##         1.000e-07         1.000e-10         1.000e-07         1.000e-10 
##       eps.outlier             eps.x warn.limit.reject warn.limit.meanrw 
##         8.643e-05         4.911e-11         5.000e-01         5.000e-01 
##      nResample         max.it       best.r.s       k.fast.s          k.max 
##            500             50              2              1            200 
##    maxit.scale      trace.lev            mts     compute.rd fast.s.large.n 
##            200              0           1000              0           2000 
##                   psi           subsampling                   cov 
##            "bisquare"         "nonsingular"         ".vcov.avar1" 
## compute.outlier.stats 
##                  "SM" 
## seed : int(0)

El siguiente gráfico muestra la linea de regresión del modelo lineal clásico (violeta) frente a la regresión del modelo robusto (amarillo).

Se puede apreciar muy claramente como el modelo robusto tiene una pendiente mas baja ajustando en menor medida a los jugadores de mayor cotización.

ggplot(train_data, aes(x = Gls, y = precio)) +
  geom_point() +
  geom_smooth(method = "lm", formula = y ~ x, color="darkviolet", se = FALSE) +
  geom_line(data = pred_modelo_lmrob_goles, aes(x = Gls, y = precio_pred), color = "yellow") +
  theme_bw()

Interpretación del Modelo

• El modelo establece una relación lineal simple entre el precio del jugador y los goles anotados
• Por cada gol anotado, el precio del jugador aumenta en €890,535; mucho menor al estimado por el método clásico de €3,267,375
• El intercepto es €3,040,824, que representa el precio base estimado para un jugador sin goles también presente una notable baja frente al del modelo clásico de €5,238,452
• El R² ajustado es 0.2177, lo que indica que el modelo explica aproximadamente el 21.8% de la variabilidad en los precios, observando una dismunición considerable frente al 30% del modelo clásico.

Evaluación y comparación de modelos frente a datos de prueba

modelos_simples <- list(simple_1 = modelo_clasico_goles, 
                simple_2 = modelo_lmrob_goles)

lista_predicciones_testing = map(.x = modelos_simples, .f = augment, newdata = test_data) 


goles_clasico_test = lista_predicciones_testing$simple_1 %>%  
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))

goles_robusto_test = lista_predicciones_testing$simple_2 %>%  
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))


metrica_goles <- rbind(goles_clasico_test[c(1,3),], goles_robusto_test[c(1,3),])

modelitos_simples <- c(rep("Clasico - Goles",2),rep("Robusto - Goles",2))
metricas <- cbind(modelitos_simples, metrica_goles)
kable(metricas)

modelitos_simples	.metric	.estimator	.estimate
Clasico - Goles	rmse	standard	17503869
Clasico - Goles	mae	standard	9732598
Robusto - Goles	rmse	standard	19142968
Robusto - Goles	mae	standard	8713804

• El RMSE es menor para el modelo clásico, sin embargo, al estar trabajando con datos que tienen outliers lo correcto es compararlo contra los valores de MAE.
• El MAE es menor para el modelo robusto, mostrando un mejor desempeño frente al modelo clásico.

Primero Modelo Multiple Robusto

\(log(Precio)\) = \(Goles\) + \(Edad\) + \(Edad^2\) + \(Asistencias\) + \(Continente\) \(de\) \(nacimiento\) \(del\) \(jugador\) + \(Liga\) \(donde\) \(juega\)

modelo_multiple_lmrob_2 <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                 continente + current_club_domestic_competition_id, 
                               data=train_data)
summary(modelo_multiple_lmrob_2)

## 
## Call:
## lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + continente + current_club_domestic_competition_id, 
##     data = train_data)
##  \--> method = "MM"
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -4.15651 -0.71534  0.01675  0.68707  3.45838 
## 
## Coefficients:
##                                          Estimate Std. Error t value Pr(>|t|)
## (Intercept)                              5.796426   1.235981   4.690 3.06e-06
## Gls                                      0.111085   0.010745  10.339  < 2e-16
## Age                                      0.772800   0.090728   8.518  < 2e-16
## I(Age^2)                                -0.016112   0.001655  -9.734  < 2e-16
## Ast                                      0.170219   0.014713  11.569  < 2e-16
## continenteamerica                        0.439570   0.130353   3.372 0.000771
## continenteasia_oceania                   0.065008   0.310255   0.210 0.834070
## continenteeuropa                         0.089042   0.106069   0.839 0.401378
## current_club_domestic_competition_idFR1 -0.231087   0.106080  -2.178 0.029578
## current_club_domestic_competition_idGB1  0.917136   0.110887   8.271 3.66e-16
## current_club_domestic_competition_idIT1 -0.014964   0.101669  -0.147 0.883015
## current_club_domestic_competition_idL1  -0.282461   0.098817  -2.858 0.004335
##                                            
## (Intercept)                             ***
## Gls                                     ***
## Age                                     ***
## I(Age^2)                                ***
## Ast                                     ***
## continenteamerica                       ***
## continenteasia_oceania                     
## continenteeuropa                           
## current_club_domestic_competition_idFR1 *  
## current_club_domestic_competition_idGB1 ***
## current_club_domestic_competition_idIT1    
## current_club_domestic_competition_idL1  ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Robust residual standard error: 1.024 
## Multiple R-squared:  0.4842, Adjusted R-squared:  0.4793 
## Convergence in 17 IRWLS iterations
## 
## Robustness weights: 
##  101 weights are ~= 1. The remaining 1056 ones are summarized as
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
## 0.06249 0.86890 0.94640 0.90070 0.98330 0.99900 
## Algorithmic parameters: 
##        tuning.chi                bb        tuning.psi        refine.tol 
##         1.548e+00         5.000e-01         4.685e+00         1.000e-07 
##           rel.tol         scale.tol         solve.tol          zero.tol 
##         1.000e-07         1.000e-10         1.000e-07         1.000e-10 
##       eps.outlier             eps.x warn.limit.reject warn.limit.meanrw 
##         8.643e-05         2.910e-09         5.000e-01         5.000e-01 
##      nResample         max.it       best.r.s       k.fast.s          k.max 
##            500             50              2              1            200 
##    maxit.scale      trace.lev            mts     compute.rd fast.s.large.n 
##            200              0           1000              0           2000 
##                   psi           subsampling                   cov 
##            "bisquare"         "nonsingular"         ".vcov.avar1" 
## compute.outlier.stats 
##                  "SM" 
## seed : int(0)

Interpretación del Modelo

• El modelo utiliza la transformación logarítmica de la variable precio y mantiene las mismas variables predictoras
• Los coeficientes más significativos son:
  • Goles: +0.111 (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de asistencias y edad aumenta un 11.7% por cada gol anotado.
  • Asistencias: +0.170 (p-value < 2e-16). Esto indica que el precio de los jugadores que tienen misma cantidad de goles y edad aumenta un 18.5% por cada asistencia adicional.
  • Edad: efecto cuadrático significativo (p-value < 2e-16)
  • América: +0.440 respecto a África (p-value = 0.0008), indica un aumento estadísticamete significativo de 55.2% en el precio de los jugadores americanos con respecto a los africanos. Es mayor con respecto al modelo clásico, con lo cual al quitarle peso a los jugadores mas caros podemos decir que los jugadores americanos son aún mas apreciados que los africanos.
  • Premier League: +0.917 respecto a la liga de referencia, (p-value < 3.66e-16) indica un aumento estadísticamente significativo de 150.2% en el precio de los jugadores de la Premier League con respecto a los jugadores de La Liga (España)
  • Ligue 1 (Francia): -0.231 respecto a la liga de referencia, (p-value = 0.03) indica una disminución estadísticamente significativa de 20.6% en el precio de los jugadores de la Ligue 1 con respecto a los jugadores de La Liga.
  • Bundesliga: -0.282 respecto de la liga de referencia (p-value = 0.004) indica una disminución estadísticamente significativa de 24.6% en el preicio de los jugadores de la Bundesliga con respecto a La Liga.
• El R² ajustado es 0.4793, similar al modelo anterior pero con mejor interpretabilidad, aumentando un 1.74% con respecto al módelo clásico.

ESTO NO SE SI CORRESPONDE PONERLO PORQUE AL SER UNA FORMA NO PARAMÉTRICA CREO QUE NO CORRESPONDE

Diagnóstico

#Diagnóstico
datos_augmentados <- augment(modelo_multiple_lmrob_2)
datos_augmentados$.std.resid <- datos_augmentados$.resid/(modelo_multiple_lmrob_2$scale*sqrt(1-hatvalues(modelo_multiple_lmrob_2)))
datos_augmentados$.hat <- hatvalues(modelo_multiple_lmrob_2)
g13 <- ggplot(datos_augmentados, aes(.fitted, .resid)) +
  geom_point() +
  geom_hline(yintercept = 0) +
  geom_smooth(se = FALSE) +
  labs(title = "Residuos vs valores predichos") + 
  theme_bw()
g14 <- ggplot(datos_augmentados, aes(sample = .std.resid)) +
  stat_qq() +
  geom_abline() +
  labs(title = "Normal QQ plot") + 
  theme_bw()
g15 <- ggplot(datos_augmentados, aes(.fitted, sqrt(abs(.std.resid)))) +
  geom_point() +
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Scale-location plot")
g16 <- ggplot(datos_augmentados, aes(.hat, .std.resid)) +
  geom_vline(size = 2, colour = "white", xintercept = 0) +
  geom_hline(size = 2, colour = "white", yintercept = 0) +
  geom_point() + 
  geom_smooth(se = FALSE) + 
  theme_bw() +
  labs(title = "Residual vs leverage")
grid.arrange(g13, g14, g15, g16, nrow = 2)

Evaluación y comparación de modelos frente a datos de prueba

modelos_comparacion <- list(multiple_2 = modelo_clasico_multiple,
                robusto_2 = modelo_multiple_lmrob_2)

lista_predicciones_testing = map(.x = modelos_comparacion, .f = augment, newdata = test_data) 


metricas2_test = lista_predicciones_testing$multiple_2 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas3_test = lista_predicciones_testing$robusto_2 %>% 
  mutate(exp_fitted= exp(.fitted)) %>%
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))


metrica <- rbind(metricas2_test[c(1,3),], metricas3_test[c(1,3),])

modelitos_comparacion <- c(rep("Multiple - log(Precio)",2),
               rep("Robusto - log(Precio) - psi = bisquare",2))
metricas <- cbind(modelitos_comparacion, metrica)
kable(metricas)

modelitos_comparacion	.metric	.estimator	.estimate
Multiple - log(Precio)	rmse	standard	17508456
Multiple - log(Precio)	mae	standard	7357616
Robusto - log(Precio) - psi = bisquare	rmse	standard	17592430
Robusto - log(Precio) - psi = bisquare	mae	standard	7302473

• El RMSE es menor para el modelo clásico, sin embargo, al estar trabajando con datos que tienen outliers lo correcto es compararlo contra los valores de MAE.
• El MAE es menor para el modelo robusto, mostrando un mejor desempeño frente al modelo clásico.

Modelos Robustos con otras funciones \(\rho\)

Se aplica la misma fórmula que el modelo anterior pero en lugar de usar la función \(\psi\) por defecto bisqueare hacemos 5 modelos nuevos usando en cada uno diferentes \(\rho\): lqq, welsh, optimal, hampel y ggw.

Evaluación de todos los modelos

modelo_multiple_lmrob_lqq <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                   continente + current_club_domestic_competition_id, 
                                 data=train_data,
                           psi = "lqq")

modelo_multiple_lmrob_welsh <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                     continente + current_club_domestic_competition_id, 
                                   data=train_data,
                                   psi = "welsh")

modelo_multiple_lmrob_optimal <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                       continente + current_club_domestic_competition_id, 
                                     data=train_data,
                                     psi = "optimal")


modelo_multiple_lmrob_hampel <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                         continente + current_club_domestic_competition_id, 
                                       data=train_data,
                                       psi = "hampel")

modelo_multiple_lmrob_ggw <- lmrob(formula = log(precio) ~ Gls + Age + I(Age^2) + Ast + 
                                         continente + current_club_domestic_competition_id, 
                                       data=train_data,
                                       psi = "ggw")


modelos <- list(multiple_1 = modelo_clasico_multiple_1, 
                multiple_2 = modelo_clasico_multiple,
                robusto_2 = modelo_multiple_lmrob_2,
                robusto_3 = modelo_multiple_lmrob_lqq,
                robusto_4 = modelo_multiple_lmrob_welsh,
                robusto_5 = modelo_multiple_lmrob_optimal,
                robusto_6 = modelo_multiple_lmrob_hampel,
                robusto_7 = modelo_multiple_lmrob_ggw)

lista_predicciones_testing = map(.x = modelos, .f = augment, newdata = test_data) 


metricas1_test = lista_predicciones_testing$multiple_1 %>%  
  metrics(truth=precio, estimate=.fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas2_test = lista_predicciones_testing$multiple_2 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas3_test = lista_predicciones_testing$robusto_2 %>% 
  mutate(exp_fitted= exp(.fitted)) %>%
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas4_test = lista_predicciones_testing$robusto_3 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas5_test = lista_predicciones_testing$robusto_4 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas6_test = lista_predicciones_testing$robusto_5 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas7_test = lista_predicciones_testing$robusto_6 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))

metricas8_test = lista_predicciones_testing$robusto_7 %>%  
  mutate(exp_fitted= exp(.fitted)) %>% 
  metrics(truth=precio, estimate=exp_fitted) %>%
  mutate(.estimate=round(.estimate, 4))



metricas <- rbind(metricas1_test[c(1,3),], metricas2_test[c(1,3),])
metricas <- rbind(metricas, metricas3_test[c(1,3),])
metricas <- rbind(metricas, metricas4_test[c(1,3),])
metricas <- rbind(metricas, metricas5_test[c(1,3),])
metricas <- rbind(metricas, metricas6_test[c(1,3),])
metricas <- rbind(metricas, metricas7_test[c(1,3),])
metricas <- rbind(metricas, metricas8_test[c(1,3),])

modelitos <- c(rep("Multiple - Precio",2),
               rep("Multiple - log(Precio)",2),
               rep("Robusto - log(Precio) - psi = bisqare",2),
               rep("Robusto - log(Precio) - psi = lqq",2),
               rep("Robusto - log(Precio) - psi = welsh",2), 
               rep("Robusto - log(Precio) - psi = optimal",2),
               rep("Robusto - log(Precio) - psi = hampel",2),
               rep("Robusto - log(Precio) - psi = ggw",2))
metricas <- cbind(modelitos, metricas)
kable(metricas)

modelitos	.metric	.estimator	.estimate
Multiple - Precio	rmse	standard	15450180
Multiple - Precio	mae	standard	8469906
Multiple - log(Precio)	rmse	standard	17508456
Multiple - log(Precio)	mae	standard	7357616
Robusto - log(Precio) - psi = bisqare	rmse	standard	17592430
Robusto - log(Precio) - psi = bisqare	mae	standard	7302473
Robusto - log(Precio) - psi = lqq	rmse	standard	17622569
Robusto - log(Precio) - psi = lqq	mae	standard	7311621
Robusto - log(Precio) - psi = welsh	rmse	standard	17606604
Robusto - log(Precio) - psi = welsh	mae	standard	7307849
Robusto - log(Precio) - psi = optimal	rmse	standard	17415950
Robusto - log(Precio) - psi = optimal	mae	standard	7276587
Robusto - log(Precio) - psi = hampel	rmse	standard	17679420
Robusto - log(Precio) - psi = hampel	mae	standard	7328352
Robusto - log(Precio) - psi = ggw	rmse	standard	17629310
Robusto - log(Precio) - psi = ggw	mae	standard	7313388

• El MAE de todos los modelos robustos es menor que el de los modelos clásicos
• El modelo que utiliza la función \(\rho\) optimal tiene le menor MAE, siendo el de mejor desempeño. Esto es posible ya ya que la funcion optimal es apropiada para datos donde los outliers no son muy pronunciados, que parece ser el caso del precio de los jugadores.

Conclusiones

El análisis estadístico revela patrones fundamentales en la valoración de jugadores que desafían varias percepciones tradicionales del mercado. La evidencia empírica demuestra una clara segmentación del mercado europeo, con ineficiencias significativas que crean oportunidades estratégicas.

La elección metodológica de utilizar regresión robusta con transformación logarítmica demostró ser crucial para la validez del análisis. El método MM-estimation implementado en Robustbase, que utiliza por defecto la función bisquare, permitió manejar eficazmente la heterogeneidad inherente al mercado de fichajes, donde las valoraciones extremas son comunes pero no necesariamente outliers estadísticos. La transformación logarítmica no solo mejoró las propiedades estadísticas del modelo, sino que también proporcionó una interpretación más intuitiva en términos de variaciones porcentuales, alineándose naturalmente con la forma en que el mercado evalúa los cambios en el valor de los jugadores. El uso de estimadores robustos reveló que el mercado de fichajes, aunque volátil, mantiene una estructura subyacente que puede ser modelada de manera más precisa cuando se utilizan métodos que equilibran robustez y eficiencia estadística.

El modelo robusto, con un R² ajustado de 47.93%, captura las dinámicas fundamentales del mercado mientras filtra el “ruido” especulativo. La efectividad de la función bisquare sugiere que, contrario a la percepción popular, las valoraciones extremas en el mercado siguen patrones identificables y no son puramente especulativas.

La Premier League mantiene una prima de valoración del 150.2% sobre La Liga, un diferencial que excede significativamente las diferencias en ingresos operativos entre estas ligas. Esta sobrevaloración sistemática sugiere una burbuja estructural en el mercado inglés, particularmente notable en comparación con Bundesliga (-24.6%) y Ligue 1 (-20.6%), donde el talento parece estar sistemáticamente infravalorado.

Una observación particularmente relevante es la mayor valoración de las asistencias (+18.5%) sobre los goles (+11.7%). Esta diferencia refleja una evolución en la comprensión del valor creativo en el fútbol moderno, donde la capacidad de generar oportunidades se premia por encima de la finalización. Este patrón sugiere una sofisticación creciente en la evaluación del talento.

La relación cuadrática con la edad emerge como un factor crítico en la valoración, señalando una ventana óptima de valoración que el mercado reconoce consistentemente. Este patrón tiene implicaciones profundas para la gestión de activos deportivos y la planificación de plantillas a largo plazo.

La brecha de valoración del 55.2% entre jugadores americanos y africanos, controlando por rendimiento y liga, revela un sesgo de mercado significativo. Esta disparidad, estadísticamente significativa (p-value = 0.0008), indica una ineficiencia de mercado estructural que trasciende el rendimiento deportivo puro.

Las ineficiencias identificadas en el mercado sugieren que el valor real de un jugador puede diferir significativamente de las valoraciones de mercado actuales, especialmente en ligas secundarias y mercados emergentes. La transformación logarítmica del modelo revela que estas discrepancias siguen patrones predecibles y explotables.

El análisis también señala una evolución en la estructura del mercado, donde los factores tradicionales de valoración están siendo complementados por métricas más sofisticadas. La significativa prima por creatividad sugiere un mercado que está comenzando a valorar más acertadamente las contribuciones tácticas complejas.

Estos hallazgos indican que el mercado de transferencias, aunque cada vez más sofisticado, mantiene ineficiencias estructurales significativas. La combinación de sesgos geográficos, primas de liga y valoración de habilidades específicas crea un panorama complejo pero analíticamente navegable para la identificación de valor.

Bibliografía

• Davidcariboo. (n.d.). Football Data from Transfermarkt [Data set]. Kaggle. https://www.kaggle.com/datasets/davidcariboo/player-scores
• Orkunaktas. (n.d.). Premier League All Players Stats 23/24 [Data set]. Kaggle. https://www.kaggle.com/datasets/orkunaktas/premier-league-all-players-stats-2324
• Apunte de Regresión Lineal. María Eugenia Szretter Noste, Facultad de Ciencias Exactas y Naturales, Universidad de Buenos Aires, Agosto - Octubre de 2017. http://mate.dm.uba.ar/~meszre/apunte_regresion_lineal_szretter.pdf
• Chun Yu & Weixin Yao (2016). Robust linear regression: A review and comparison. Communications in Statistics - Simulation and Computation, https://www.tandfonline.com/doi/abs/10.1080/03610918.2016.1202271
• Clay Ford (2018). Interpreting Log Transformations in a Linear Model. University of Virginia Library. https://library.virginia.edu/data/articles/interpreting-log-transformations-in-a-linear-model